;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;scrolling-windows.lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;
;;  this file defines a class of windows which scroll.
;;
;;  all you have to do is define a window-draw-contents for the window.
;;  the rest is taken care of.
;;

(eval-when (eval compile)
  (require 'traps)
  (require 'records))

;;constants for interfacing with the control manager

;part-codes of the scroll bar.  Because we use these with the #. reader macro,
;they are evaled at read time.  For these reason, they only need to be present
;at eval and compile time, not at load time.

(eval-when (eval compile)
  (defconstant $InUpButton 20)
  (defconstant $InDownButton 21)
  (defconstant $InPageUp 22)
  (defconstant $InPageDown 23)
  (defconstant $InThumb 129))

(defobject *scrolling-window* *window*)

(defobfun (exist *scrolling-window*) (init-list)
  (usual-exist init-list)
  (without-interrupts
  (have 'hscroll(_getNewControl :word 256 :ptr wptr :ptr))
  (have 'vscroll (_getNewControl :word 257 :ptr wptr :ptr))
  (have 'origin #@(0 0))
  (have 'content-rect (make-record :rect))
  (have 'field-size (getf init-list :field-size (window-size)))
  (movescrollbars)
  (size-content-rect)))

(defobfun (size-content-rect *scrolling-window*) ()
  (rset content-rect rect.topleft (rref wptr window.portrect.topleft))
  (rset content-rect
        rect.bottomright
        (subtract-points (rref wptr window.portrect.bottomright) #@(15 15))))

(defobfun (window-close *scrolling-window*) ()
  (without-interrupts
   (_DisposControl :ptr vscroll)             ;dispose of the scroll controls
   (_DisposControl :ptr hscroll)
   (usual-window-close)
   (dispose-record content-rect :rect)))

(defobfun (window-deactivate-event-handler *scrolling-window*) ()
  (usual-window-deactivate-event-handler)
  (_hidecontrol :ptr vscroll)
  (_hidecontrol :ptr hscroll))

(defobfun (window-activate-event-handler *scrolling-window*) ()
  (usual-window-activate-event-handler)
  (_showcontrol :ptr vscroll)
  (_showcontrol :ptr hscroll))


(defobfun (window-zoom-event-handler *scrolling-window*) (msgw)
  (with-port wptr
    (_eraserect :ptr (rref wptr window.portrect)))
  (usual-window-zoom-event-handler msgw)
  (movescrollbars))

(defobfun (set-window-size *scrolling-window*) (h &optional v)
  (without-interrupts
   (inval-scrollbars)       
   (usual-set-window-size (make-point h v))
   (movescrollbars)))

(defobfun (inval-scrollbars *scrolling-window*) ()
  (with-port wptr
    (with-dereferenced-handles ((v vscroll)
                                (h hscroll))
      (_invalrect :ptr (rref v :control.rect :storage :pointer))
      (_invalrect :ptr (rref h :control.rect :storage :pointer)))))

#|
(defobfun (inval-scrollbars *scrolling-window*) ()
  (with-port wptr
  (rlet ((scroll-rect :rect)) 
    (copy-record (rref wptr window.portrect) :rect scroll-rect)
    (rset scroll-rect rect.left (- (rref scroll-rect rect.right) 15))
    (_invalrect :ptr scroll-rect)
    (copy-record (rref wptr window.portrect) :rect scroll-rect)
    (rset scroll-rect rect.top (- (rref scroll-rect rect.bottom) 15))
    (_invalrect :ptr scroll-rect))))
|#

(defobfun (moveScrollBars *scrolling-window*) ()
  (_hideControl :ptr vscroll)
  (_MoveControl :ptr vscroll
                :word (- (rref wptr window.portrect.right) 15)
                :word (- (rref wptr window.portrect.top) 1 ))
  (_sizeControl :ptr vscroll
                :word 16
                :word (- (rref wptr window.portrect.bottom)
                         (rref wptr window.portrect.top)
                         13))
  (_showControl :ptr vscroll)
  (_hideControl :ptr hscroll)
  (_MoveControl :ptr hscroll
                :word (- (rref wptr window.portrect.left) 1)
                :word (- (rref wptr window.portrect.bottom) 15 ))
  (_sizeControl :ptr hscroll
                :word (- (rref wptr window.portrect.right)
                         (rref wptr window.portrect.left)
                         13)
                :word 16)
  (_showControl :ptr hscroll))

(defobfun (window-click-event-handler *scrolling-window*) (where)
  "call window-scroll-click-event-handler if click is in scroll bar"
  (let* ((message (%inc-ptr *current-event* 2))
         (code (_FindControl :long where
                             :ptr wptr
                             :ptr message
                             :word))
         (control-handle (%get-ptr message)))
    (if (and control-handle
             (or (eq control-handle vscroll)
                 (eq control-handle hscroll)))
      (window-scroll-click-event-handler control-handle code where)
      (let ((offset (make-point (_getctlvalue :ptr hscroll :word)
                                (_getctlvalue :ptr vscroll :word))))
        (_SetOrigin :long offset)
        (_ClipRect :ptr content-rect)
        (usual-window-click-event-handler (add-points where offset))
        (_ClipRect :ptr (rref wptr window.portrect))
        (_SetOrigin :long 0)))))

(defobfun (window-scroll-click-event-handler *scrolling-window*) (control-handle
                                                                  part-code
                                                                  where)
  (case part-code
    ((#.$InUpButton #.$InDownButton #.$InPageUp #.$InPageDown)
     (_TrackControl :ptr control-handle
                    :long where
                    :ptr trackproc
                    :word))
    ((#.$InThumb)
     (progn (_TrackControl :ptr control-handle
                           :long where
                           :ptr nil
                           :word)
            (scroll-window-contents)))))

(defpascal trackproc ((my-control :ptr) (part-code :word))
  (_setctlvalue :ptr my-control 
                :word (+ (_getctlvalue :ptr my-control :word)
                        (case  part-code
                           (#.$InUpButton -1)
                           (#.$InDownButton 1)
                           (#.$InPageUp -10)
                           (#.$InPageDown 10)
                           (otherwise 0))))
  (scroll-window-contents))


(defobfun (scroll-window-contents *scrolling-window*) ()
   (let* ((old-origin origin)
          (delta nil)
          (region (_newrgn :ptr)))
     (rlet ((trect :rect))
       (setq origin (make-point 
                     (_getctlvalue :ptr hscroll :word)
                     (_getctlvalue :ptr vscroll :word))
             delta (subtract-points old-origin origin))
       (_scrollrect :ptr content-rect
                    :word (point-h delta)
                    :word (point-v delta)
                    :ptr region)
       (_setorigin :word (point-h origin)
                   :word (point-v origin))
       (with-dereferenced-handles ((region-pointer region))
         (_OffsetRect :ptr (rref region-pointer region.rgnbbox
                                 :storage :pointer)
                       :long origin)
         (_ClipRect :ptr (rref region-pointer region.rgnbbox
                               :storage :pointer)))
       (window-draw-contents)
       (_DisposRgn :ptr region)
       (_setorigin :word 0
                   :word 0)
       (_ClipRect :ptr (rref wptr window.portrect)))))


(defobfun (window-update-event-handler *scrolling-window*) ()
   (rlet ((r :rect))
     (_beginupdate :ptr wptr)
     (_eraserect :ptr (rref wptr window.portrect))
     (_ClipRect :ptr (rref wptr window.portrect))
     (_drawgrowicon :ptr wptr)
     (_Draw1Control :ptr vscroll)
     (_Draw1Control :ptr hscroll)
     (size-content-rect)
     (copy-record content-rect :rect r)
     (_OffsetRect :ptr r :long origin)
     (_ClipRect :ptr r)
     (_setorigin :word (point-h origin)
                 :word (point-v origin))
     (window-draw-contents)
     (_setorigin :word 0
                 :word 0)
     (_ClipRect :ptr (rref wptr window.portrect))
     (_endupdate :ptr wptr)))


#|
(defobject *scrolling-window-demo* *scrolling-window*)

(defobfun (window-draw-contents *scrolling-window-demo*) ()
  (with-port wptr
    (rlet ((r :rect :topleft #@(20 50)
              :bottomright #@(100 100)))
      (_FrameRect :ptr r))))

(setq my-window (oneof *scrolling-window-demo*
                  :window-size #@(320 205)
                  :window-title "Scroll Me"))

|#